PC-Blue - MS DOS Public Domain Library/PC-Blue MS-DOS Public Domain Library - NYACC.iso/vol017/recipe.pas

Pascal/Delphi Source File | 1987-01-11 | 19.3 KB | 793 lines

{++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
**  PROGRAM TITLE    THE RECIPE SYSTEM
**
**  Translated by:    Raymond E. Penley from the BASIC
**            version into Pascal.
**
**  DATE WRITTEN:    23 FEB 1980
**
**  WRITTEN FOR:    Computer hobbyists
**
**  PROGRAM SUMMARY:
**
**  The recipe system stores recipes and retrives recipies
**  by means of a numeric key that represents the foods
**  used in the meal.  Foods are divided into four
**  categories according to their nutritional value.
**  For more comments see the original program.
**
**  INPUT AND OUTPUT FILES:
**    RCPDAT.XXX and RCPDAT.YYY
**           - the DATA and the backup files
**    RCPDAT.MST - the statistics file
**
**  MODIFICATION RECORD:
**    28 Feb 80    -
**     2 Jun 80    -Rewritten for Pascal/Z v 3.0
**     8 Jun 80    -Rewrote SCAN
**
**  ORIGINAL PROGRAM:
**    T.G.LEWIS, 'THE MIND APPLIANCE'
**    HAYDEN BOOK COMPANY
**
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
PROGRAM RECIPE;

CONST
  default = 80;        (* Default length for strings *)
  str_len = 73;        (* Length of a recipe line plus one char *)
  StrMax  = 255;    (* Max Length of strings allowed   *)
  EOS      = '|';    (* End of String marker *)
  Master  = 'RCPDAT.MST';
  Tab20      = 20 ;
  Tab15      = 15 ;
  INPUT   = 0;        (*****   PASCAL/Z ver 3.n   *****)

TYPE
  ALFA       = STRING 10 ;
  BYTE       = 0..255;
  LINE       = string default;
  Mstring  = string 255 ;
  DataType = record
         MR,        (* MaxRecords    *)
         CR : integer;    (* Curr_Rcds    *)
         F1,        (* current_ID    *)
         F2,        (* backup_ID    *)
         date : string 14 (* last_update *)
         end;
  S$0   = STRING 0 ;        { zero length string }
  S$255 = STRING 255 ;        { max string length  }

VAR
  adding_recipies,    (* adding recipies state flag *)
  comanding,        (* Command mode flag *)
  done            (* Program execution flag *)
        : boolean;
  bell,            (* ASCII bell char *)
  ch,
  command    : char;
  data        : datatype;
  End_of_File,        (* End of File flag *)
  End_of_Text        (* End of Text flag *)
        : boolean;
  error_flag    : BYTE;
  CRT_width,    (* Width of video display *)
  Curr_Rcds,    (* No. of current active records *)
  Hash,        (* Computed Index value of Recipe *)
  ix,        (* global indexer *)
  Last,        (* length of last line read *)
  MaxRecords,    (* Maximum records allowed *)
  TTY_width    (* Width of teletype device *)
        : integer;
  Last_update    : string 14; (* date of last file update *)
  matrix    : packed array[1..5] of LINE;
    (*  File Identifiers <FID>  *)
  current_ID,            (* Current file ID *)
  backup_ID    :string 14;    (* Back up file ID *)
    (* File descriptor <FCB> *)
  stats        :FILE of datatype;

    {$C- [ctrl-c checking OFF]}
    {$F- [floating point error checking OFF]}
    {$M- [integer mult & divd checking OFF]}

(*---Required for Pascal/Z supplied string functions---*)
FUNCTION LENGTH(X: S$255): INTEGER; EXTERNAL;
PROCEDURE SETLENGTH(VAR X :S$0; Y :INTEGER); EXTERNAL;



(*----------------------------------------------*)
(*          DISK I/O            *)
(*----------------------------------------------*)



Procedure OPEN_MASTER;
begin
  (* OPEN file RECIPE.MST for READ assign stats *)
      RESET(master, stats);
  READ(stats, data );
  with data do begin
    MaxRecords := MR;
    Curr_Rcds  := CR;
    current_ID    := F1;
    backup_ID    := F2;
    last_update := date
    end(* with *)
end;

Procedure UPDATE_MASTER;
begin
  (* OPEN file RECIPE.MST for WRITE assign stats *)
      REWRITE(master, stats);
  with data do begin
    MR := MaxRecords;
    CR := Curr_Rcds;
    F1 := current_ID ;
    F2 := backup_ID ;
    date := last_update
    end(* with *);
  WRITE(stats, data )
end;

Procedure GETLINE(VAR fx : TEXT;
          VAR INBUFF : LINE );
{ This Procedure gets a line of text from a disk file.
  Returns:
    End_of_Text = true if the input buffer length
            exceeded.
    End_of_File = true if EOF
    INBUFF    = input buffer        }
VAR    CH   : CHAR;
    ix, length : integer;
begin
  length := 0;
  End_of_Text := FALSE;
  SETLENGTH(INBUFF,0);
  WHILE NOT EOF(fx) AND (CH <> EOS) DO
    begin
    If length < str_len then
      begin(* valid *)
    READ(fx, CH );
    length := SUCC(length);
    APPEND(INBUFF,CH)
      end(* If *)
    ELSE
    End_of_Text := TRUE;
    end(* WHILE *);
    If length >= last then
      last:=length
    Else
      REPEAT
    APPEND(INBUFF,EOS);
    last := PRED(last)
      UNTIL last=length;
  End_of_File := EOF(fx)
end(*---of GetLine---*);

Procedure PUTLINE( VAR fx   : TEXT;
           VAR this : LINE );
{ This Procedure puts a line of text to a disk file }
VAR    CH  : char;
    pos : integer;
begin
  pos := 0;
  REPEAT
    pos := SUCC(pos);
    CH := this[ pos ];
    If CH <> EOS then Write(fx, CH)
  UNTIL (CH = EOS) OR (pos = str_len);
  Write(fx, EOS) (* Mark the End of String *)
end(*---of PUTLINE---*);

Procedure PUT_RECORD( VAR fx    : TEXT;
              VAR Index : integer );
VAR    jx : integer;
begin
  Writeln(fx, Index:5);
  For jx:=1 to 5 do
    PUTLINE(fx,matrix[jx] );
end(*---of PUT_RECORD---*);

Procedure GET_RECORD(VAR fx : TEXT;
             VAR Index : integer );
VAR    JJ : integer;
begin
  READLN (fx, Index);
  FOR JJ := 1 to 5 DO
    GETLINE(fx,matrix[JJ]);
end(*---of GET_RECORD---*);



(*----------------------------------------------*)
(*        CONSOLE I/O            *)
(*----------------------------------------------*)



Procedure KEYIN(VAR CIX : char); EXTERNAL;
(*---Single char input directly from keyboard---*)

Procedure PRINT(this : Mstring);
(*    Print the string 'this' until EOS     *)
VAR
  CH : CHAR;
  pos : integer;
begin
  pos := 0;
  REPEAT
    pos := SUCC(pos);
    CH := this[ pos ];
    If CH <> EOS then Write(CH)
  UNTIL (CH = EOS) OR (pos = str_len);
  Writeln
end(*---of PRINT---*);

Procedure SCAN( VAR Arg_string    : LINE ;
            count    : integer ;
        VAR status    : BYTE  );
(*----------------------------------------------*)
(* version: 3.1 /8 JUN 80/ by R.E.Penley    *)
(*----------------------------------------------*
** Scan will scan your input line and return:
    STATUS:
      0    -OK, valid inputs
      1    -an attempt was made to exceed "count"
         characters - so I truncated the string at
         count chars for you.
      2    -an invalid character was detected.
         You figure out what to do with it!
    LENGTH(arg string) = 0 means a null string input.
**
    Valid Alphanumeric chars are the ASCII char set
    starting at the space [ CHR(32) ] and
    ending at the tilde [ CHR(126) ].
 *----------------------------------------------*
GLOBAL  StrMax = 255;
    BYTE   = 0..255;
    LINE   = STRING Default;
 *----------------------------------------------*)
VAR    loop    : (scanning, found, notfound);
    ix    : 1..StrMax;
begin
  { return status = 0 if no errors detected. }
  status := 0;
  { return status = 1 if requested length is exceeded }
  If LENGTH(arg_string) > count then
    begin
    status := 1;
    SETLENGTH(arg_string,count)
    end;
  loop := scanning;
  ix := 1;
  While (loop=scanning) do
  { return status = 2 if any invalid chars found }
    begin
    If ix > LENGTH(arg_string) then
      loop := notfound{excellent - no invalid chars}
    Else
      If arg_string[ix] IN [' '..'~'] then{good show - keep going}
    ix := SUCC(ix)
      Else
    begin
    loop := found{invalid char};
    status := 2
    end
    end{while}
End(*---of SCAN 3.1---*);



(*----------------------------------------------*)
(*        UTILITY ROUTINES        *)
(*----------------------------------------------*)


Function YORN : boolean ;
{
    YES/NO INPUT MODULE
Returns:
    TRUE FOR 'Y' or 'y' INPUT
    FALSE FOR 'N' or 'n' INPUT
}
VAR
  ans : ALFA;
  valid : boolean;
begin
  REPEAT
    valid := true;
    READ(ans);
    CASE ans[1] of
    'Y','y':    YORN := true;
    'N','n':    YORN := false;
    Else:    begin
          valid := false;
          Writeln(BELL, 'Please answer ''Y'' or ''N'' ')
        end
    end{case}
  Until valid{response}
End(*---of YORN---*);

Procedure CLEAR;
(* Device dependent procedure    *)
begin
  Write( CHR(26) )
end;

Procedure SKIP(L1 : integer);
VAR ix : integer;
begin
  FOR ix:=1 to L1 do Writeln
end;

Procedure PAUSE;
CONST    sign = 'Type return to continue:';
VAR    dummy : char;
begin
  SKIP(4);
  Write(sign);
  Readln(dummy)
end;

Procedure BREAK;
begin
  CLEAR;
  SKIP(5)
end;

Procedure DRAW(picture : Mstring; count : integer );
{ Draw a picture count times }
VAR ix : integer;
begin
  FOR ix:=1 to count DO Write( picture );
  Writeln
end(*---of DRAW---*);

Procedure ShowRecipe;
VAR JJ : integer;
begin
  FOR JJ := 1 to 5 DO
    PRINT(matrix[JJ]) ;
  Writeln
end(*--of ShowRecipe--*);

Procedure Display_One(VAR Index : integer);
begin
  Writeln;
  Writeln( 'Recipe #', Index:5 );
  Writeln;
  DRAW( '- ', 20);
  Writeln;
  ShowRecipe;
  skip(4)
end(*---of Display_One---*);


(*----------------------------------------------*
 *           ADD MODULE            *
 *----------------------------------------------*)

    {$C+ [ctrl-c checking ON]}

Procedure InputFeatures(VAR I : integer);
(******************************************
 *    Input Features of Recipe      *
 ******************************************)
(*
RETURNS:
  Hash value computed for various choices
**)
CONST    Msg1    = 'None of these' ;
VAR    F, D, V, P :integer;

    Function QUIRY(X2 : integer) : integer;
    VAR ix : integer;
        cix : char;
    begin
      REPEAT
        Writeln;
        Write('Enter Choice (1 to', X2:2, ') ');
        KEYIN(cix);write(cix);
        ix := (ORD(cix) - ORD('0'))
      UNTIL (ix>=1) AND (ix<=X2) ;
      QUIRY := ix
    end;

begin
  Writeln;
  Writeln( ' Enter number of choice :');
  Writeln;
  Writeln( ' ':Tab15, 'Fibre Foods' );
  Writeln;
  Writeln( ' ':Tab15, '1.  Bread (flour)');
  Writeln( ' ':Tab15, '2.  Oats' );
  Writeln( ' ':Tab15, '3.  Rice');
  Writeln( ' ':Tab15, '4.  Corn' );
  Writeln( ' ':Tab15, '5.  Macaroni');
  Writeln( ' ':Tab15, '6.  Noodles' );
  Writeln( ' ':Tab15, '7.  Spaghetti');
  Writeln( ' ':Tab15, '8.  ', Msg1 );
  F := QUIRY(8);
  BREAK;
  Writeln;
  Writeln( ' ':Tab15, 'Protein' );
  Writeln;
  Writeln( ' ':Tab15, '1.  Beef');
  Writeln( ' ':Tab15, '2.  Poultry' );
  Writeln( ' ':Tab15, '3.  Fish');
  Writeln( ' ':Tab15, '4.  Eggs' );
  Writeln( ' ':Tab15, '5.  Beans');
  Writeln( ' ':Tab15, '6.  Nuts' );
  Writeln( ' ':Tab15, '7.  ', Msg1 );
  P := QUIRY(7);
  BREAK;
  Writeln;
  Writeln( ' ':Tab15, 'Dairy' );
  Writeln;
  Writeln( ' ':Tab15, '1.  Milk');
  Writeln( ' ':Tab15, '2.  Cheese' );
  Writeln( ' ':Tab15, '3.  Cottage Cheese');
  Writeln( ' ':Tab15, '4.  Cream' );
  Writeln( ' ':Tab15, '5.  Sour Cream');
  Writeln( ' ':Tab15, '6.  ', Msg1 );
  D := QUIRY(6);
  BREAK;
  Writeln;
  Writeln( ' ':Tab15, 'Fruits and Vegetables' );
  Writeln;
  Writeln( ' ':Tab15, '1.  Citrus');
  Writeln( ' ':Tab15, '2.  Melon' );
  Writeln( ' ':Tab15, '3.  Juices');
  Writeln( ' ':Tab15, '4.  Greens' );
  Writeln( ' ':Tab15, '5.  Yellows & Reds' );
  Writeln( ' ':Tab15, '6.  ', Msg1 );
  V := QUIRY(6);
  CLEAR;

   {*****************************************}
   {  Compute the index value by assigning   }
   {  a weight to each digit in the set.     }
   {*****************************************}

    I := 252*F + 36*P + 6*D + V - 295

   {******************************************}

end{of InputFeatures};



Procedure InputRecipe;
(*---------------------------------------*
 *    Input individual recipies     *
 *---------------------------------------*)
LABEL
  99; (*---EXIT---*)
CONST
  prompt = '>';
VAR
  state  : (absent, done, adding) ;
  ix, jx : integer;
  temp     : STRING 14;
  One_Line : LINE;
  YES     : boolean;
    (* File descriptors <FCB> *)
  current,
  backup : TEXT;

  PROCEDURE CORRECT;
  CONST   question = 'Are there any corrections to be made';
      msg1 = 'Enter <cr> return if correct or Reenter the line';
  begin
    REPEAT
      BREAK;
      Writeln(bell,' ':(TTY_width DIV 2) -10, 'HERE IS YOUR RECIPE');
      Writeln;
      ShowRecipe;
      Writeln;
      Writeln(question);
      YES := YORN;
      If YES then
    begin
      BREAK;
      Writeln(msg1);
      Writeln;
      For ix:=1 to 5 do
        begin
          REPEAT
        PRINT(matrix[ix]);
        SETLENGTH(one_line,0);
        READLN(one_Line);
        SCAN(one_Line, str_len - 1, error_flag);
        If (LENGTH(one_Line) > 0) AND (error_flag=0) then
          begin
          APPEND(one_Line,EOS);
          matrix[ix] := one_Line
          end;
        If error_flag IN [1,2] then
          CASE error_flag of
            1: writeln('Invalid length, please reinput');
            2: writeln('Alpha numerics only, please reinput')
          End{case}
          Until error_flag=0;
        end{for}
    end(* If *)
    Until not YES
  end(*---of Correct---*);

    Function adding_desired : boolean ;
    CONST    addquest = 'Do you want to ADD recipies? ';
    begin
      PAUSE;
      BREAK;
      Write(addquest);
      adding_desired := YORN;
      CLEAR
    end;

begin(*---InputRecipe---*)
  If not adding_desired then{EXIT}goto 99;
  adding_recipies := true ;
  state := adding ;
  (* OPEN file backup_ID for WRITE assign backup *)
    REWRITE(backup_ID, backup);
  (* OPEN file current_ID for READ assign current *)
    RESET(current_ID, current);

    {$C- [ctrl-c checking OFF]}

  If NOT EOF(current) then
    begin(* COPY current to back_up *)
      ix := 0 ;
      While ix < Curr_Rcds do
    begin
      ix := SUCC(ix);
      GET_RECORD(current,hash);
      PUT_RECORD(backup,hash)
    end(* while *)
    end(* COPY current to back_up *);

    {$C+ [ctrl-c checking ON]}

(*---Input/Enter additional recipies until done---*)
(*---or curr_records > Max_Records allowed     ---*)

  REPEAT
  If Curr_Rcds > MaxRecords then
    state := done
  Else
    begin(*---add more recipies---*)
      Writeln('Identify Recipe with features. First ');
      InputFeatures(HASH);
      BREAK;
      Writeln('Now Enter 5 lines of the recipe');
      Writeln;
      For jx := 1 to 5 DO
    begin
      REPEAT
        write(prompt);
        SETLENGTH(one_line,0);
        READLN(one_line);
        SCAN(one_Line, str_len - 1, error_flag);
        If error_flag IN [1,2] then
          CASE error_flag of
          1:   writeln('Invalid length, please reinput');
          2:   writeln('Alpha numerics only, please reinput')
          End{case}
      Until error_flag=0;
      APPEND(one_Line,EOS);
      matrix[jx] := one_Line
    end{For};
      Correct(* if required *);
      Curr_Rcds := SUCC(Curr_Rcds);
      PUT_RECORD(backup,hash);
      If not adding_desired then state := done;
    end(*---add more recipies---*)
  UNTIL state<>adding;
(*--------------------------------------------*)
(*        SWAP file ID`s              *)
(*    Back Up file is now the Current file  *)
(*--------------------------------------------*)
  temp := backup_ID;
  backup_ID := current_ID;
  current_ID := temp;

  UPDATE_MASTER;(*--status file--*)

99:(* Come here if do not desire to add *)
End{*--of InputRecipe--*};


(*--------------------------------------*)
(*          DUMP/FIND MODULE        *)
(*--------------------------------------*)

PROCEDURE FILE_SCAN ;
(*
GLOBAL
  MaxRecords = maximum allowed records
  Curr_Rcds = # of recipes in file
*)
VAR
  state : (absent, found, searching) ;
  Rcds,
  index : integer;
  fa    : TEXT;  (* FCB. File descriptor *)

    Procedure DUMP;
    (**********************************)
    (*  OUTPUT all Recipes from file  *)
    (**********************************)
    begin
      REPEAT
        If Rcds > Curr_Rcds then
          state := absent
        Else
          begin
        Rcds := SUCC(Rcds);
        GET_RECORD(fa,hash);
        Display_One(hash);
        PAUSE
          end(* else *)
      UNTIL state<>searching
    end(*--of DUMP--*);

    Procedure FIND;
    (************************************)
    (*    Lookup recipes from file    *)
    (************************************)
    begin            {$C- [ctrl-c checking OFF]}
      InputFeatures(Index);
      REPEAT
        If Rcds > Curr_Rcds then
          state := absent
        Else
          begin
        Rcds := SUCC(Rcds);
        GET_RECORD(fa,hash);
        If HASH=Index then
          begin
            CLEAR;
            Display_One(hash);
            PAUSE
          end
          end(* else *)
      Until state<>searching
    end(*--of Lookup--*);    {$C+ [ctrl-c checking ON]}

begin(*---File_Scan---*)
  CLEAR;
  state := absent;
  If adding_recipies then{read in new stats}
    OPEN_MASTER;
  (* OPEN file current_ID for READ assign fa *)
      RESET(current_ID, fa);
  If NOT EOF(fa) then
    If Curr_rcds=0 then
      state := absent
    Else
      begin
    state := searching ;
    Rcds := 1 ;
    CASE command of
      'O', 'o':    DUMP;
      'F', 'f':    FIND
    End{case commmand of}
      end(* else *);
  If state=absent then
    begin
    BREAK;
    Writeln('That''s all the Recipes on File')
    end;
  PAUSE
end(*---of File_Scan---*);

(*--------------------------------------*)
(*          INITIALIZATION        *)
(*--------------------------------------*)


Procedure INIT1;
begin
  bell        := CHR(7) ;
  CRT_width    := 80 ;
  TTY_width    := 72 ;
  last        := str_len ;
  MaxRecords    := 75 ;
(*    maximum number of records =
        # BYTES per Record  times  # of records
    # BYTES per record =
        # chars per line + overhead per line times
        # of lines.                ***)
  Curr_Rcds    :=  0 ;
  Last_Update    := 'YY/MM/DD      ';
  current_ID    := 'RCPDAT.XXX    ';
  backup_ID    := 'RCPDAT.YYY    ';
  adding_recipies := false;
end;

Procedure INIT2;
begin
   (* OPEN file `RECIPE.MST` for READ assign stats *)
      RESET(master, stats);
  If EOF(stats) then(* not found *)
    (* OPEN file `RECIPE.MST` for WRITE assign stats *)
      UPDATE_MASTER
  Else
    begin(* READ in data record *)
      READ(stats, data );
      with data do begin
        MaxRecords := MR;
        Curr_Rcds  := CR;
        current_ID := F1;
        backup_ID  := F2;
        last_update := date
        end(* with *)
    end(* READ in data record *);
  SKIP(5);
  Writeln('Last update of Recipe data file was ', last_update);
  Writeln('File currently consists of ', Curr_Rcds:4, ' Recipies');
  Writeln;
  Write('Please enter todays date <YY/MM/DD>  ');
  last_update := '              ';{<<<=== 14 spaces required ===}
  For ix:=1 to 8 do
    begin
      if (ix=3) or (ix=6) then
    ch := '/'
      else
    KEYIN(ch);
      write(ch);
      last_update[ix] := ch
    end{for};
  writeln
end(*--of INIT2---*);

(*----------------------------------------------*
 *        MAIN PROGRAM            *
 *----------------------------------------------*)

BEGIN
  INIT1;    (* start the initialization process here *)
  CLEAR;
  DRAW('************',TTY_width DIV 12);
  Writeln;
  Writeln( ' ':22, 'The Recipe System');
  Writeln;
  DRAW('************',TTY_width DIV 12);
  INIT2;    (* finish init now *)
  { Now execute the program until done }
  done := false;
  While not done do
    begin
    CLEAR;
    DRAW('************',TTY_width DIV 12);
    SKIP(3);
    Writeln( ' ':Tab15, 'Select One of the following:');
    Writeln;
    Writeln( ' ':Tab20, 'I(nput Recipes');
    Writeln( ' ':Tab20, 'O(utput all Recipes');
    Writeln( ' ':Tab20, 'F(ind a Recipe');
    Writeln( ' ':Tab20, 'S(top');
    comanding := true;
    WHILE comanding do
      begin
      comanding := false;
      Writeln;
      Write(' ':(Tab15), 'Enter choice   ' );
      KEYIN(command);write(command);
    CASE command of
      'I', 'i':    InputRecipe;
      'O', 'o',
      'F', 'f':    File_Scan;
      'S', 's':    done := true;
    Else:        begin
            Write(BELL);
            comanding := true
            end
    End{ case }
      end{while comanding}
    end{ while not done }
End{---of Program Recipe---}.